home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d2 / stayres.arc / STAYWNDO.340 < prev    next >
Text File  |  1988-06-27  |  16KB  |  381 lines
  1. {**********************************************************************}
  2. {                         W I N D O . I N C                            }
  3. {                     "...but I dont do floors !"                      }
  4. {**********************************************************************}
  5. {                 Kloned and Kludged by Lane Ferris                    }
  6. {                     -- The Hunters Helper --                         }
  7. {               Original Copyright 1984 by Michael A. Covington        }
  8. {               Modifications by Lynn Canning 9/25/85                  }
  9. {                 1) Foreground and Background colors added.           }
  10. {                    Monochrome monitors are automatically set         }
  11. {                    to white on black.                                }
  12. {                 2) Multiple borders added.                           }
  13. {                 3) TimeDelay procedure added.                        }
  14. {               Requirements: IBM PC or close compatible.              }
  15. {----------------------------------------------------------------------}
  16. { To make a window on the screen, call the procedure                   }
  17. {      MkWin(x1,y1,x2,y2,FG,BG,BD);                                    }
  18. {   The x and y coordinates define the window placement and are the    }
  19. {   same as the Turbo Pascal Window coordinates.                       }
  20. {   The border parameters (BD) are 0 = No border                       }
  21. {                                  1 = Single line border              }
  22. {                                  2 = Double line border              }
  23. {                                  3 = Double Top/Bottom Single sides  }
  24. {   The foreground (FG) and background (BG) parameters are the same    }
  25. {   values as the corresponding Turbo Pascal values.                   }
  26. {                                                                      }
  27. { The maximum number of windows open at one time is set at five        }
  28. { (see MaxWin=5).  This may be set to greater values if necessary.     }
  29. {                                                                      }
  30. { After the window is made, you must write the text desired from the   }
  31. { calling program.  Note that the usable text area is actually 1       }
  32. { position smaller than the window coordinates to allow for the border.}
  33. { Hence, a window defined as 1,1,80,25 would actually be 2,2,79,24     }
  34. { after the border is created.  When writing to the window in your     }
  35. { calling program, the textcolor and backgroundcolor may be changed as }
  36. { desired by using the standard Turbo Pascal commands.                 }
  37. {                                                                      }
  38. { To return to the previous screen or window, call the procedure       }
  39. {      RmWin;                                                          }
  40. {                                                                      }
  41. { The TimeDelay procedure is invoked from your calling program.  It    }
  42. { is similar to the Turbo Pascal DELAY except DELAY is based on clock  }
  43. { speed whereas TimeDelay is based on the actual clock.  This means    }
  44. { that the delay will be the same duration on all systems no matter    }
  45. { what the clock speed.                                                }
  46. { The procedure could be used for an error condition as follows:       }
  47. {     MkWin          - make an error message window                    }
  48. {     Writeln        - write error message to window                   }
  49. {     TimeDelay(5)   - leave window on screen 5 seconds                }
  50. {     RmWin          - remove error window                             }
  51. {     cont processing                                                  }
  52. {----------------------------------------------------------------------}
  53.  
  54. Const
  55.  
  56.       InitDone :boolean = false ;      { Initialization switch   }
  57.  
  58.       On     = True ;
  59.       Off    = False ;
  60.       VideoEnable = $08;               { Video Signal Enable Bit }
  61.       Bright = 8;                      { Bright Text bit}
  62.       Mono   = 7;                      {MonoChrome Mode}
  63.  
  64. Type
  65.      Imagetype  = array [1..4000] of char;  { Screen Image in the heap    }
  66.      WinDimtype = record
  67.                     x1,y1,x2,y2: integer
  68.                   end;
  69.  
  70.      Screens    = record              { Save Screen Information     }
  71.                    Image: Imagetype;  { Saved screen Image }
  72.                    Dim:   WinDimtype; { Saved Window Dimensions }
  73.                    x,y:   integer;    { Saved cursor position }
  74.                   end;
  75.  
  76.  
  77.  Var
  78.  
  79.   Win:                                { Global variable package }
  80.     record
  81.       Dim:    WinDimtype;             { Current Window Dimensions }
  82.       Depth:  integer;
  83.                    { MaxWin should be included in your program }
  84.                    { and it should be the number of windows saved }
  85.                    { at one time }
  86.                    { It should be in the const section of your program }
  87.       Stack:  array[1..MaxWin] of ^Screens;
  88.  
  89.     end;
  90.  
  91.   Crtmode     :byte      absolute $0040:$0049; {Crt Mode,Mono,Color,B&W..}
  92.   Crtwidth    :byte      absolute $0040:$004A; {Crt Mode Width, 40:80 .. }
  93.   Monobuffer  :Imagetype absolute $B000:$0000; {Monochrome Adapter Memory}
  94.   Colorbuffer :Imagetype absolute $B800:$0000; {Color Adapter Memory     }
  95.   CrtAdapter  :integer   absolute $0040:$0063; { Current Display Adapter }
  96.   VideoMode   :byte      absolute $0040:$0065; { Video Port Mode byte    }
  97.   TurboCrtMode: byte     absolute  Dseg:6;     {Turbo's Crt Mode byte    }
  98.   Video_Buffer:integer;                        { Record the current Video}
  99.   FG,                                          {Foregound color value    }
  100.   BG,                                          {Background color value   }
  101.   BD          :integer;                        {Border type Value 0..2   }
  102.   Switch      :boolean;
  103.   Delta,
  104.   Xtemp,Ytemp :integer;
  105.   x,y         :integer;
  106.  
  107. {------------------------------------------------------------------}
  108. {                     Delay for  X seconds                         }
  109. {------------------------------------------------------------------}
  110.  
  111. procedure TimeDelay (hold : integer);
  112. type
  113.   RegRec =                                { The data to pass to DOS }
  114.     record
  115.       AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
  116.     end;
  117. var
  118.   regs:regrec;
  119.   ah, al, ch, cl, dh:byte;
  120.   sec               :string[2];
  121.   tmptime, result, secn, error, secn2, diff :integer;
  122.  
  123. begin
  124.   ah := $2c;                       {Get Time-Of-Day from DOS}
  125.   with regs do                     {Will give back Ch:hours }
  126.                                    {Cl:minutes,Dh:seconds   }
  127.     ax := ah shl 8 + al;           {Dl:hundreds             }
  128.   intr($21,regs);
  129.  
  130.   with regs do
  131.     str(dx shr 8:2, sec);          {Get seconds      }
  132.                                    {with leading null}
  133.   if (sec[1] = ' ') then
  134.     sec[1]:= '0';
  135.   val(sec, secn, error);           {Conver seconds to integer}
  136.   repeat                           { stay in this loop until the time }
  137.      ah := $2c;                    { has expired }
  138.      with regs do
  139.         ax := ah shl 8 + al;
  140.      intr($21,regs);               {Get current time-of-day}
  141.  
  142.      with regs do                  {Normalize to Char}
  143.         str(dx shr 8:2, sec);
  144.      if (sec[1] = ' ') then
  145.         sec[1]:= '0';
  146.      val(sec, secn2, error);       {Convert seconds to integer}
  147.      diff := secn2 - secn;         {Number of elapsed seconds}
  148.      if diff < 0 then            { we just went over the minute }
  149.         diff := diff + 60;       { so add 60 seconds }
  150.   until diff > hold;             { has our time expired yet }
  151. end; { procedure TimeDelay }
  152.  
  153. {------------------------------------------------------------------}
  154. {          Get Absolute postion of Cursor into parameters x,y      }
  155. {------------------------------------------------------------------}
  156. Procedure Get_Abs_Cursor (var x,y :integer);
  157.   Var
  158.       Active_Page  : byte absolute $0040:$0062;  { Current Video Page Index}
  159.       Crt_Pages    : array[0..7] of integer absolute $0040:$0050 ;
  160.  
  161.    Begin
  162.  
  163.       X := Crt_Pages[active_page];     { Get Cursor Position       }
  164.       Y := Hi(X)+1;                    { Y get Row                 }
  165.       X := Lo(X)+1;                    { X gets Col position       }
  166.    End;
  167. {------------------------------------------------------------------}
  168. {          Turn the Video On/Off to avoid Read/Write snow          }
  169. {------------------------------------------------------------------}
  170. Procedure Video (Switch:boolean);
  171.    Begin
  172.       If (Switch = Off) then
  173.       Port[CrtAdapter+4] := (VideoMode - VideoEnable)
  174.       else Port[CrtAdapter+4] := (VideoMode or VideoEnable);
  175.    End;
  176. {------------------------------------------------------------------}
  177. {     InitWin Saves the Current (whole) Screen                     }
  178. {------------------------------------------------------------------}
  179. Procedure InitWin;
  180.   { Records Initial Window Dimensions }
  181.    Begin
  182.  
  183.      with Win.Dim do
  184.        begin x1:=1; y1:=1; x2:=crtwidth; y2:=25 end;
  185.      Win.Depth:=0;
  186.      InitDone := True ;                    { Show initialization Done }
  187. end;
  188. {------------------------------------------------------------------}
  189. {       BoxWin Draws a Box around the current Window               }
  190. {------------------------------------------------------------------}
  191. procedure BoxWin(x1,y1,x2,y2, BD, FG, BG :integer);
  192.  
  193.   { Draws a box, fills it with blanks, and makes it the current }
  194.   { Window.  Dimensions given are for the box; actual Window is }
  195.   { one unit smaller in each direction.                         }
  196.  
  197. var
  198.     x,y,I      : integer;
  199.     TB,SID,TLC,TRC,BLC,BRC   :integer;
  200.  
  201. begin
  202.   if Crtmode = 7 then begin
  203.     FG := 7;
  204.     BG := 0;
  205.     end;
  206.  
  207.   Window(x1,y1,x2,y2);              {Make the Window}
  208.   TextColor(FG) ;                   {Set the colors}
  209.   TextBackground(BG);
  210.  
  211.  
  212.   Case BD of                        {Make Border characters}
  213.     0:;                             {No border option}
  214.     1:begin                         {Single line border option}
  215.       TB  := 196;                     {Top Border}
  216.       SID := 179;                     {Side Border}
  217.       TLC := 218;                     {Top Left Corner}
  218.       TRC := 191;                     {Top Right Corner}
  219.       BLC := 192;                     {Bottom Left Corner}
  220.       BRC := 217;                     {Bottom Right Corner}
  221.       end;
  222.     2:begin                         {Double line border option}
  223.       TB  := 205;
  224.       SID := 186;
  225.       TLC := 201; TRC := 187;
  226.       BLC := 200; BRC := 188;
  227.       end;
  228.     3:begin                         {Double Top/Bottom with single sides}
  229.       TB  := 205;                   {"deary and dont spare the lace"}
  230.       SID := 179;
  231.       TLC := 213; TRC := 184;
  232.       BLC := 212; BRC := 190;
  233.       end;
  234.     End;{Case}
  235.  
  236.   IF BD > 0 then begin                  { User want a border? }
  237.   { Top }
  238.      gotoxy(1,1);                       { Window Origin       }
  239.      Write( chr(TLC) );                 { Top Left Corner     }
  240.      For I:=2 to x2-x1   do             { Top Bar             }
  241.         Write( chr(TB));
  242.      Write( chr(TRC) );                 { Top Right Corner
  243.  
  244.   { Sides  }
  245.      for I:=2 to y2-y1 do
  246.        begin
  247.          gotoxy(1,I);                   { Left Side Bar       }
  248.          write( chr(SID) );
  249.          gotoxy(x2-x1+1,I) ;            { Right Side Bar      }
  250.          write( chr(SID) );
  251.        end;
  252.  
  253.   { Bottom }
  254.      gotoxy(1,y2-y1+1);                   { Bottom Left Corner }
  255.      write( chr(BLC) );
  256.      for I:=2 to x2-x1   do               { Bottom Bar         }
  257.         write( chr(TB) );
  258.  
  259.   { Make it the current Window }
  260.      Window(x1+1,y1+1,x2-1,y2-1);
  261.      write( chr(BRC) );                 { Bottom Right Corner }
  262.    end; {If BD > 0};
  263.  
  264.    gotoxy(1,1) ;
  265.    TextColor( FG) ;                { Take Low nibble 0..15  }
  266.    TextBackground (BG);            { Take High nibble  0..9 }
  267.    ClrScr;
  268.  end;
  269. {------------------------------------------------------------------}
  270. {       MkWin   Make a Window                                      }
  271. {------------------------------------------------------------------}
  272. procedure MkWin(x1,y1,x2,y2, FG, BG, BD :integer);
  273.   { Create a removable Window }
  274.  
  275. begin
  276.  
  277.   If (InitDone = false) then              { Initialize if not done yet }
  278.       InitWin;
  279.  
  280.   TurboCrtMode := CrtMode;                  {Set Textmode w/o ClrScr}
  281.   If CrtMode = 7 then Video_Buffer := $B000 {Set Ptr to Monobuffer      }
  282.   else  Video_Buffer := $B800;              {or Color Buffer            }
  283.  
  284.  
  285.   with Win do Depth:=Depth+1;              { Increment Stack pointer }
  286.   if Win.Depth>maxWin then
  287.     begin
  288.       writeln(^G,' Windows nested too deep ');
  289.       halt
  290.     end;
  291.                 {-------------------------------------}
  292.                 {       Save contents of screen       }
  293.                 {-------------------------------------}
  294.   With Win do
  295.     Begin
  296.     New(Stack[Depth]);                  { Allocate Current Screen to Heap }
  297.     Video( Off);
  298.  
  299.     If CrtMode = 7 then
  300.     Stack[Depth]^.Image := monobuffer   { set pointer to it      }
  301.     else
  302.     Stack[Depth]^.Image := colorbuffer ;
  303.  
  304.     Video( On);
  305.    End ;
  306.  
  307.  
  308.   With Win do
  309.      Begin                                { Save Screen Dimentions        }
  310.      Stack[Depth]^.Dim := Dim;
  311.      Stack[Win.Depth]^.x  := wherex;      { Save Cursor Position          }
  312.      Stack[Win.Depth]^.y  := wherey;
  313.      End ;
  314.  
  315.                                           { Validate the Window Placement}
  316.   If (X2 > 80) then                       { If off right of screen       }
  317.           begin
  318.           Delta := (X2 - 80);             { Overflow off right margin    }
  319.           If X1 > Delta then
  320.              X1 := X1 - Delta ;           { Move Left window edge        }
  321.           X2 := X2 - Delta ;              { Move Right edge on 80        }
  322.           end;
  323.   If (Y2 > 25) then                       { If off bottom   screen       }
  324.           begin
  325.           Delta := Y2 - 25;               { Overflow off right margin    }
  326.           If Y1 > Delta then
  327.              Y1 := Y1 - Delta ;           { Move Top edge up             }
  328.           Y2 := Y2 - Delta ;              { Move Bottom  24              }
  329.           end;
  330.                                           { Create the New Window  }
  331.  
  332.   BoxWin(x1,y1,x2,y2,BD,FG,BG);
  333.   If BD >0 then begin                     {Shrink window within borders}
  334.      Win.Dim.x1 := x1+1;
  335.      Win.Dim.y1 := y1+1;                     { Allow for margins }
  336.      Win.Dim.x2 := x2-1;
  337.      Win.Dim.y2 := y2-1;
  338.      end;
  339.  
  340. end;
  341. {------------------------------------------------------------------}
  342. {                          Remove Window                           }
  343. {------------------------------------------------------------------}
  344.         { Remove the most recently created removable Window }
  345.         { Restore screen contents, Window Dimensions, and   }
  346.         { position of cursor.  }
  347. Procedure RmWin;
  348.   Var
  349.     Tempbyte : byte;
  350.  
  351.    Begin
  352.    Video(Off);
  353.  
  354.    With Win do
  355.       Begin                                { Restore next Screen       }
  356.       If crtmode = 7 then
  357.       monobuffer := Stack[Depth]^.Image
  358.       else
  359.       colorbuffer := Stack[Depth]^.Image;
  360.       Dispose(Stack[Depth]);                { Remove Screen from Heap   }
  361.  
  362.    Video(On);
  363.  
  364.    With Win do                              { Re-instate the Sub-Window }
  365.     Begin                                   { Position the old cursor   }
  366.       Dim := Stack[Depth]^.Dim;
  367.       Window(Dim.x1,Dim.y1,Dim.x2,Dim.y2);
  368.       gotoxy(Stack[Depth]^.x,Stack[Depth]^.y);
  369.     end;
  370.  
  371.       Get_Abs_Cursor(x,y) ;          { New Cursor Position       }
  372.       Tempbyte :=                    { Get old Cursor attributes }
  373.            Mem[ Video_Buffer:((x-1 + (y-1) * 80 ) * 2)+1 ];
  374.  
  375.       TextColor( Tempbyte And $0F );        { Take Low nibble  0..15}
  376.       TextBackground ( Tempbyte Div 16);   { Take High nibble  0..9 }
  377.       Depth := Depth - 1
  378.     end ;
  379. end;
  380. {------------------------------------------------------------------}
  381.